home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-summary.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  33.8 KB  |  993 lines
  1. ;;; Summary gathering and formatting routines for VM
  2. ;;; Copyright (C) 1989, 1990, 1993, 1994, 1995 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-summary)
  19.  
  20. (defun vm-summary-mode-internal ()
  21.   (setq mode-name "VM Summary"
  22.     major-mode 'vm-summary-mode
  23.     mode-line-format vm-mode-line-format
  24.     ;; must come after the setting of major-mode
  25.     mode-popup-menu (and vm-use-menus
  26.                  (vm-menu-support-possible-p)
  27.                  (vm-menu-mode-menu))
  28.     buffer-read-only t
  29.     vm-summary-pointer nil
  30.     vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "")
  31.     vm-summary-no-=> (make-string (length vm-summary-=>) ? )
  32.     truncate-lines t)
  33.   ;; horizontal scrollbar off by default
  34.   ;; user can turn it on in summary hook if desired.
  35.   (and (fboundp 'set-specifier)
  36.        scrollbar-height
  37.        (set-specifier scrollbar-height (cons (current-buffer) 0)))
  38.   (use-local-map vm-summary-mode-map)
  39.   (and (vm-menu-support-possible-p)
  40.        (vm-menu-install-menus))
  41.   (and (vm-mouse-support-possible-p)
  42.        (vm-mouse-xemacs-mouse-p)
  43.        (add-hook 'mode-motion-hook 'mode-motion-highlight-line))
  44.   (if (or vm-frame-per-folder vm-frame-per-summary)
  45.       (vm-set-hooks-for-frame-deletion))
  46.   (run-hooks 'vm-summary-mode-hook)
  47.   ;; Lucid Emacs apparently used this name
  48.   (run-hooks 'vm-summary-mode-hooks))
  49.  
  50. (fset 'vm-summary-mode 'vm-mode)
  51. (put 'vm-summary-mode 'mode-class 'special)
  52.  
  53. (defun vm-summarize (&optional display)
  54.   "Summarize the contents of the folder in a summary buffer. 
  55. The format is as described by the variable vm-summary-format.  Generally
  56. one line per message is most pleasing to the eye but this is not
  57. mandatory."
  58.   (interactive "p")
  59.   (vm-select-folder-buffer)
  60.   (vm-check-for-killed-summary)
  61.   (if (null vm-summary-buffer)
  62.       (let ((b (current-buffer))
  63.         (read-only vm-folder-read-only))
  64.     (setq vm-summary-buffer
  65.           (get-buffer-create (format "%s Summary" (buffer-name))))
  66.     (save-excursion
  67.       (set-buffer vm-summary-buffer)
  68.       (abbrev-mode 0)
  69.       (auto-fill-mode 0)
  70.       (if (fboundp 'buffer-disable-undo)
  71.           (buffer-disable-undo (current-buffer))
  72.         ;; obfuscation to make the v19 compiler not whine
  73.         ;; about obsolete functions.
  74.         (let ((x 'buffer-flush-undo))
  75.           (funcall x (current-buffer))))
  76.       (setq vm-mail-buffer b
  77.         vm-folder-read-only read-only)
  78.       (vm-summary-mode-internal))
  79.     (vm-set-summary-redo-start-point t)))
  80.   (if display
  81.       (save-excursion
  82.     (if vm-frame-per-summary
  83.         (let ((w (vm-get-buffer-window vm-summary-buffer)))
  84.           (if (null w)
  85.           (progn
  86.             (vm-goto-new-frame 'summary)
  87.             (vm-set-hooks-for-frame-deletion))
  88.         (save-excursion
  89.           (select-window w)
  90.           (and vm-warp-mouse-to-new-frame
  91.                (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))
  92.     (vm-display vm-summary-buffer t
  93.             '(vm-summarize
  94.               vm-summarize-other-frame)
  95.             (list this-command))
  96.     ;; need to do this after any frame creation because the
  97.     ;; toolbar sets frame-specific height and width specifiers.
  98.     (set-buffer vm-summary-buffer)
  99.     (and (vm-toolbar-support-possible-p) vm-use-toolbar
  100.          (vm-toolbar-install-toolbar)))
  101.     (vm-display nil nil '(vm-summarize vm-summarize-other-frame)
  102.         (list this-command)))
  103.   (vm-update-summary-and-mode-line))
  104.  
  105. (defun vm-summarize-other-frame (&optional display)
  106.   "Like vm-summarize, but run in a newly created frame."
  107.   (interactive "p")
  108.   (if (vm-multiple-frames-possible-p)
  109.       (vm-goto-new-frame 'summary))
  110.   (vm-summarize display)
  111.   (if (vm-multiple-frames-possible-p)
  112.       (vm-set-hooks-for-frame-deletion)))
  113.  
  114. (defun vm-do-summary (&optional start-point)
  115.   (let ((m-list (or start-point vm-message-list))
  116.     mp
  117.     (n 0)
  118.     ;; Just for laughs, make the update interval vary.
  119.     (modulus (+ (% (vm-abs (random)) 11) 10))
  120.     (mouse-track-func
  121.         (and (vm-mouse-support-possible-p)
  122.          (vm-mouse-fsfemacs-mouse-p)
  123.          (function vm-mouse-set-mouse-track-highlight)))
  124.     summary)
  125.     (setq mp m-list)
  126.     (save-excursion
  127.       (set-buffer vm-summary-buffer)
  128.       (let ((buffer-read-only nil)
  129.         (modified (buffer-modified-p)))
  130.     (unwind-protect
  131.         (progn
  132.           (if start-point
  133.           (if (vm-su-start-of (car mp))
  134.               (progn
  135.             (goto-char (vm-su-start-of (car mp)))
  136.             (delete-region (point) (point-max)))
  137.             (goto-char (point-max)))
  138.         (erase-buffer)
  139.         (setq vm-summary-pointer nil))
  140.           ;; avoid doing long runs down the marker chain while
  141.           ;; building the summary.  use integers to store positions
  142.           ;; and then convert them to markers after all the
  143.           ;; insertions are done.
  144.           (while mp
  145.         (setq summary (vm-su-summary (car mp)))
  146.         (vm-set-su-start-of (car mp) (point))
  147.         (insert vm-summary-no-=>)
  148.         (vm-tokenized-summary-insert (car mp) (vm-su-summary (car mp)))
  149.         (vm-set-su-end-of (car mp) (point))
  150.         (setq mp (cdr mp) n (1+ n))
  151.         (if (zerop (% n modulus))
  152.             (vm-unsaved-message "Generating summary... %d" n)))
  153.           ;; now convert the ints to markers.
  154.           (if (>= n modulus)
  155.           (vm-unsaved-message "Generating summary markers... "))
  156.           (setq mp m-list)
  157.           (while mp
  158.         (and mouse-track-func (funcall mouse-track-func
  159.                            (vm-su-start-of (car mp))
  160.                            (vm-su-end-of (car mp))))
  161.         (vm-set-su-start-of (car mp) (vm-marker (vm-su-start-of (car mp))))
  162.         (vm-set-su-end-of (car mp) (vm-marker (vm-su-end-of (car mp))))
  163.         (setq mp (cdr mp))))
  164.       (set-buffer-modified-p modified))
  165.     (run-hooks 'vm-summary-redo-hook)))
  166.     (if (>= n modulus)
  167.     (vm-unsaved-message "Generating summary... done"))))
  168.  
  169. (defun vm-do-needed-summary-rebuild ()
  170.   (if (and vm-summary-redo-start-point vm-summary-buffer)
  171.       (progn
  172.     (vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads)
  173.     (vm-do-summary (and (consp vm-summary-redo-start-point)
  174.                 vm-summary-redo-start-point))
  175.     (setq vm-summary-redo-start-point nil)
  176.     (and vm-message-pointer
  177.          (vm-set-summary-pointer (car vm-message-pointer)))
  178.     (setq vm-need-summary-pointer-update nil))
  179.     (and vm-need-summary-pointer-update
  180.      vm-summary-buffer
  181.      vm-message-pointer
  182.      (progn
  183.        (vm-set-summary-pointer (car vm-message-pointer))
  184.        (setq vm-need-summary-pointer-update nil)))))
  185.  
  186. (defun vm-update-message-summary (m)
  187.   (if (and (vm-su-start-of m)
  188.        (marker-buffer (vm-su-start-of m)))
  189.       (let ((modified (buffer-modified-p))
  190.         (mouse-track-func
  191.          (and (vm-mouse-support-possible-p)
  192.           (vm-mouse-fsfemacs-mouse-p)
  193.           (function vm-mouse-set-mouse-track-highlight)))
  194.         summary)
  195.     (save-excursion
  196.       (setq summary (vm-su-summary m))
  197.       (set-buffer (marker-buffer (vm-su-start-of m)))
  198.       (let ((buffer-read-only nil)
  199.         (selected nil)
  200.         (modified (buffer-modified-p)))
  201.         (unwind-protect
  202.         (save-excursion
  203.           (goto-char (vm-su-start-of m))
  204.           (setq selected (not (looking-at vm-summary-no-=>)))
  205.           ;; We do a little dance to update the text in
  206.           ;; order to make the markets in the text do
  207.           ;; what we want.
  208.           ;;
  209.           ;; 1. We need to avoid having the su-start-of
  210.           ;;    and su-end-of market clumping together at
  211.           ;;    the start position.
  212.           ;;
  213.           ;; 2. We want the window point market (w->pointm
  214.           ;;    in the Emacs display code) to move to the
  215.           ;;    start of the summary entry if it is
  216.           ;;    anywhere within the su-start-of to
  217.           ;;    su-end-of region.
  218.           ;;
  219.           ;; We achieve (2) by deleting before inserting.
  220.           ;; Reversing the order of insertion/deletion
  221.           ;; pushes the point marker into the next
  222.           ;; summary entry. We achieve (1) by inserting a
  223.           ;; placeholder character at the end of the
  224.           ;; summary entry before deleting the region.
  225.           (goto-char (vm-su-end-of m))
  226.           (insert-before-markers "z")
  227.           (goto-char (vm-su-start-of m))
  228.           (delete-region (point) (1- (vm-su-end-of m)))
  229.           (if (not selected)
  230.               (insert vm-summary-no-=>)
  231.             (insert vm-summary-=>))
  232.           (vm-tokenized-summary-insert m (vm-su-summary m))
  233.           (delete-char 1)
  234.           (run-hooks 'vm-summary-update-hook)
  235.           (and mouse-track-func (funcall mouse-track-func
  236.                          (vm-su-start-of m)
  237.                          (vm-su-end-of m)))
  238.           (if (and selected vm-summary-highlight-face)
  239.               (vm-summary-highlight-region (vm-su-start-of m) (point)
  240.                            vm-summary-highlight-face)))
  241.           (set-buffer-modified-p modified)))))))
  242.  
  243. (defun vm-set-summary-pointer (m)
  244.   (if vm-summary-buffer
  245.       (let ((w (vm-get-visible-buffer-window vm-summary-buffer))
  246.         (mouse-track-func
  247.            (and (vm-mouse-support-possible-p)
  248.             (vm-mouse-fsfemacs-mouse-p)
  249.             (function vm-mouse-set-mouse-track-highlight)))
  250.         (old-window nil))
  251.     (vm-save-buffer-excursion
  252.       (unwind-protect
  253.           (progn
  254.         (set-buffer vm-summary-buffer)
  255.         (if w
  256.             (progn
  257.               (setq old-window (selected-window))
  258.               (select-window w)))
  259.         (let ((buffer-read-only nil))
  260.           (if (and vm-summary-pointer
  261.                (vm-su-start-of vm-summary-pointer))
  262.               (progn
  263.             (goto-char (vm-su-start-of vm-summary-pointer))
  264.             (insert vm-summary-no-=>)
  265.             (delete-char (length vm-summary-=>))
  266.             (and mouse-track-func
  267.                  (funcall mouse-track-func
  268.                       (- (point) (length vm-summary-=>))
  269.                      (point)))))
  270.           (setq vm-summary-pointer m)
  271.           (goto-char (vm-su-start-of m))
  272.           (let ((modified (buffer-modified-p)))
  273.             (unwind-protect
  274.             (progn
  275.               (insert vm-summary-=>)
  276.               (delete-char (length vm-summary-=>))
  277.               (and mouse-track-func
  278.                    (funcall mouse-track-func
  279.                     (- (point) (length vm-summary-=>))
  280.                        (point))))
  281.               (set-buffer-modified-p modified)))
  282.           (forward-char (- (length vm-summary-=>)))
  283.           (if vm-summary-highlight-face
  284.               (vm-summary-highlight-region
  285.                (vm-su-start-of m) (vm-su-end-of m)
  286.                vm-summary-highlight-face))
  287.           (and w vm-auto-center-summary (vm-auto-center-summary))
  288.           (run-hooks 'vm-summary-pointer-update-hook)))
  289.         (and old-window (select-window old-window)))))))
  290.  
  291. (defun vm-summary-highlight-region (start end face)
  292.   (cond ((fboundp 'make-overlay)
  293.      (if (and vm-summary-overlay (overlay-buffer vm-summary-overlay))
  294.          (move-overlay vm-summary-overlay start end)
  295.        (setq vm-summary-overlay (make-overlay start end))
  296.        (overlay-put vm-summary-overlay 'evaporate nil)
  297.        (overlay-put vm-summary-overlay 'face face)))
  298.     ((fboundp 'make-extent)
  299.      (if (and vm-summary-overlay (extent-live-p vm-summary-overlay))
  300.          (set-extent-endpoints vm-summary-overlay start end)
  301.        (setq vm-summary-overlay (make-extent start end))
  302.        (set-extent-property vm-summary-overlay 'detachable nil)
  303.        (set-extent-property vm-summary-overlay 'face face)))))
  304.  
  305. (defun vm-auto-center-summary ()
  306.   (if vm-auto-center-summary
  307.       (if (or (eq vm-auto-center-summary t) (not (one-window-p t)))
  308.       (recenter '(4)))))
  309.  
  310. (defun vm-sprintf (format-variable message &optional tokenize)
  311.   ;; compile the format into an eval'able s-expression
  312.   ;; if it hasn't been compiled already.
  313.   (if (not (eq (get format-variable 'vm-compiled-format)
  314.            (symbol-value format-variable)))
  315.       (vm-compile-format format-variable tokenize))
  316.   ;; The local variable name `vm-su-message' is mandatory here for
  317.   ;; the format s-expression to work.
  318.   (let ((vm-su-message message))
  319.     (eval (get format-variable 'vm-format-sexp))))
  320.  
  321. (defun vm-tokenized-summary-insert (message tokens)
  322.   (if (stringp tokens)
  323.       (insert tokens)
  324.     (let (token)
  325.       (while tokens
  326.     (setq token (car tokens))
  327.     (cond ((stringp token)
  328.            (insert token))
  329.           ((eq token 'number)
  330.            (insert (vm-padded-number-of message)))
  331.           ((eq token 'mark)
  332.            (insert (vm-su-mark message)))
  333.           ((eq token 'thread-indent)
  334.            (if (and vm-summary-show-threads
  335.             (natnump vm-summary-thread-indent-level))
  336.            (insert-char ?\ (* vm-summary-thread-indent-level
  337.                       (vm-th-thread-indentation message))))))
  338.     (setq tokens (cdr tokens))))))
  339.  
  340. (defun vm-compile-format (format-variable &optional tokenize)
  341.   (let ((format (symbol-value format-variable))
  342.     (case-fold-search nil)
  343.     (done nil)
  344.     (list nil)
  345.     (sexp nil)
  346.     (sexp-fmt nil)
  347.     (last-match-end 0)
  348.     token conv-spec)
  349.     (store-match-data nil)
  350.     (while (not done)
  351.       (setq token nil)
  352.       (while
  353.       (and (not token)
  354.            (string-match
  355.         "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([aAcdfFhHiIlLmMnstTwyz*%]\\|U[A-Za-z]\\)"
  356.         format (match-end 0)))
  357.     (setq conv-spec (aref format (match-beginning 5)))
  358.     (if (memq conv-spec '(?a ?A ?c ?d ?f ?F ?h ?H ?i ?L ?I ?l ?M
  359.                  ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* ))
  360.         (progn
  361.           (cond ((= conv-spec ?a)
  362.              (setq sexp (cons (list 'vm-su-attribute-indicators
  363.                         'vm-su-message) sexp)))
  364.             ((= conv-spec ?A)
  365.              (setq sexp (cons (list 'vm-su-attribute-indicators-long
  366.                         'vm-su-message) sexp)))
  367.             ((= conv-spec ?c)
  368.              (setq sexp (cons (list 'vm-su-byte-count
  369.                         'vm-su-message) sexp)))
  370.             ((= conv-spec ?d)
  371.              (setq sexp (cons (list 'vm-su-monthday
  372.                         'vm-su-message) sexp)))
  373.             ((= conv-spec ?f)
  374.              (setq sexp (cons (list 'vm-su-interesting-from
  375.                         'vm-su-message) sexp)))
  376.             ((= conv-spec ?F)
  377.              (setq sexp (cons (list 'vm-su-interesting-full-name
  378.                         'vm-su-message) sexp)))
  379.             ((= conv-spec ?h)
  380.              (setq sexp (cons (list 'vm-su-hour
  381.                         'vm-su-message) sexp)))
  382.             ((= conv-spec ?H)
  383.              (setq sexp (cons (list 'vm-su-hour-short
  384.                         'vm-su-message) sexp)))
  385.             ((= conv-spec ?i)
  386.              (setq sexp (cons (list 'vm-su-message-id
  387.                         'vm-su-message) sexp)))
  388.             ((= conv-spec ?I)
  389.              (if tokenize
  390.              (setq token ''thread-indent)
  391.                (setq sexp (cons (list 'vm-su-thread-indent
  392.                           'vm-su-message) sexp))))
  393.             ((= conv-spec ?l)
  394.              (setq sexp (cons (list 'vm-su-line-count
  395.                         'vm-su-message) sexp)))
  396.             ((= conv-spec ?L)
  397.              (setq sexp (cons (list 'vm-su-labels
  398.                         'vm-su-message) sexp)))
  399.             ((= conv-spec ?m)
  400.              (setq sexp (cons (list 'vm-su-month
  401.                         'vm-su-message) sexp)))
  402.             ((= conv-spec ?M)
  403.              (setq sexp (cons (list 'vm-su-month-number
  404.                         'vm-su-message) sexp)))
  405.             ((= conv-spec ?n)
  406.              (if tokenize
  407.              (setq token ''number)
  408.                (setq sexp (cons (list 'vm-padded-number-of
  409.                           'vm-su-message) sexp))))
  410.             ((= conv-spec ?s)
  411.              (setq sexp (cons (list 'vm-su-subject
  412.                         'vm-su-message) sexp)))
  413.             ((= conv-spec ?T)
  414.              (setq sexp (cons (list 'vm-su-to-names
  415.                         'vm-su-message) sexp)))
  416.             ((= conv-spec ?t)
  417.              (setq sexp (cons (list 'vm-su-to
  418.                         'vm-su-message) sexp)))
  419.             ((= conv-spec ?U)
  420.              (setq sexp
  421.                (cons (list 'vm-run-user-summary-function
  422.                        (list 'quote
  423.                          (intern
  424.                           (concat
  425.                            "vm-summary-function-"
  426.                            (substring
  427.                         format
  428.                         (1+ (match-beginning 5))
  429.                         (+ 2 (match-beginning 5))))))
  430.                        'vm-su-message) sexp)))
  431.             ((= conv-spec ?w)
  432.              (setq sexp (cons (list 'vm-su-weekday
  433.                         'vm-su-message) sexp)))
  434.             ((= conv-spec ?y)
  435.              (setq sexp (cons (list 'vm-su-year
  436.                         'vm-su-message) sexp)))
  437.             ((= conv-spec ?z)
  438.              (setq sexp (cons (list 'vm-su-zone
  439.                         'vm-su-message) sexp)))
  440.             ((= conv-spec ?*)
  441.              (if tokenize
  442.              (setq token ''mark)
  443.                (setq sexp (cons (list 'vm-su-mark
  444.                           'vm-su-message) sexp)))))
  445.           (cond ((and (not token) (match-beginning 1))
  446.              (setcar sexp
  447.                  (list 'vm-left-justify-string (car sexp)
  448.                    (string-to-int
  449.                     (substring format
  450.                            (match-beginning 2)
  451.                            (match-end 2))))))
  452.             ((and (not token) (match-beginning 2))
  453.              (setcar sexp
  454.                  (list 'vm-right-justify-string (car sexp)
  455.                    (string-to-int
  456.                     (substring format
  457.                            (match-beginning 2)
  458.                            (match-end 2)))))))
  459.           (cond ((and (not token) (match-beginning 3))
  460.              (setcar sexp
  461.                  (list 'vm-truncate-string (car sexp)
  462.                    (string-to-int
  463.                     (substring format
  464.                            (match-beginning 4)
  465.                            (match-end 4)))))))
  466.           (setq sexp-fmt
  467.             (cons (if token "" "%s")
  468.               (cons (substring format
  469.                        last-match-end
  470.                        (match-beginning 0))
  471.                 sexp-fmt))))
  472.       (setq sexp-fmt
  473.         (cons "%%"
  474.               (cons (substring format
  475.                        (or last-match-end 0)
  476.                        (match-beginning 0))
  477.                 sexp-fmt))))
  478.       (setq last-match-end (match-end 0)))
  479.       (if (not token)
  480.       (setq sexp-fmt
  481.         (cons (substring format last-match-end (length format))
  482.               sexp-fmt)
  483.         done t))
  484.       (setq sexp-fmt (apply 'concat (nreverse sexp-fmt)))
  485.       (if sexp
  486.       (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
  487.     (setq sexp sexp-fmt))
  488.       (if tokenize
  489.       (setq list (nconc list (if (equal sexp "") nil (list sexp))
  490.                 (and token (list token)))
  491.         sexp nil
  492.         sexp-fmt nil)))
  493.     (put format-variable 'vm-compiled-format format)
  494.     (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp))))
  495.  
  496. (defun vm-get-header-contents (message header-name-regexp)
  497.   (let ((contents nil)
  498.     regexp)
  499.     (setq regexp (concat "^\\(" header-name-regexp "\\)")
  500.       message (vm-real-message-of message))
  501.     (save-excursion
  502.       (set-buffer (vm-buffer-of (vm-real-message-of message)))
  503.       (save-restriction
  504.     (widen)
  505.     (goto-char (vm-headers-of message))
  506.     (let ((case-fold-search t))
  507.       (while (and (re-search-forward regexp (vm-text-of message) t)
  508.               (save-excursion (goto-char (match-beginning 0))
  509.                       (vm-match-header)))
  510.         (if contents
  511.         (setq contents
  512.               (concat contents ", " (vm-matched-header-contents)))
  513.           (setq contents (vm-matched-header-contents))))))
  514.       contents )))
  515.  
  516. (defun vm-left-justify-string (string width)
  517.   (if (>= (length string) width)
  518.       string
  519.     (concat string (make-string (- width (length string)) ?\ ))))
  520.  
  521. (defun vm-right-justify-string (string width)
  522.   (if (>= (length string) width)
  523.       string
  524.     (concat (make-string (- width (length string)) ?\ ) string)))
  525.  
  526. (defun vm-truncate-string (string width)
  527.   (cond ((<= (length string) width)
  528.      string)
  529.     ((< width 0)
  530.      (substring string width))
  531.     (t
  532.      (substring string 0 width))))
  533.  
  534. (defun vm-su-attribute-indicators (m)
  535.   (concat
  536.    (cond ((vm-deleted-flag m) "D")
  537.      ((vm-new-flag m) "N")
  538.      ((vm-unread-flag m) "U")
  539.      (t " "))
  540.    (cond ((vm-filed-flag m) "F")
  541.      ((vm-written-flag m) "W")
  542.      (t " "))
  543.    (cond ((vm-replied-flag m) "R")
  544.      ((vm-forwarded-flag m) "Z")
  545.      ((vm-redistributed-flag m) "B")
  546.      (t " "))
  547.    (cond ((vm-edited-flag m) "E")
  548.      (t " "))))
  549.  
  550. (defun vm-su-attribute-indicators-long (m)
  551.   (concat
  552.    (cond ((vm-deleted-flag m) "D")
  553.      ((vm-new-flag m) "N")
  554.      ((vm-unread-flag m) "U")
  555.      (t " "))
  556.    (if (vm-replied-flag m) "r" " ")
  557.    (if (vm-forwarded-flag m) "z" " ")
  558.    (if (vm-redistributed-flag m) "b" " ")
  559.    (if (vm-filed-flag m) "f" " ")
  560.    (if (vm-written-flag m) "w" " ")
  561.    (if (vm-edited-flag m) "e" " ")))
  562.  
  563. (defun vm-su-byte-count (m)
  564.   (or (vm-byte-count-of m)
  565.       (vm-set-byte-count-of
  566.        m
  567.        (int-to-string
  568.     (- (vm-text-end-of (vm-real-message-of m))
  569.        (vm-text-of (vm-real-message-of m)))))))
  570.  
  571. (defun vm-su-weekday (m)
  572.   (or (vm-weekday-of m)
  573.       (progn (vm-su-do-date m) (vm-weekday-of m))))
  574.  
  575. (defun vm-su-monthday (m)
  576.   (or (vm-monthday-of m)
  577.       (progn (vm-su-do-date m) (vm-monthday-of m))))
  578.  
  579. (defun vm-su-month (m)
  580.   (or (vm-month-of m)
  581.       (progn (vm-su-do-date m) (vm-month-of m))))
  582.  
  583. (defun vm-su-month-number (m)
  584.   (or (vm-month-number-of m)
  585.       (progn (vm-su-do-date m) (vm-month-number-of m))))
  586.  
  587. (defun vm-su-year (m)
  588.   (or (vm-year-of m)
  589.       (progn (vm-su-do-date m) (vm-year-of m))))
  590.  
  591. (defun vm-su-hour-short (m)
  592.   (let ((string (vm-su-hour m)))
  593.     (if (> (length string) 5)
  594.     (substring string 0 5)
  595.       string)))
  596.  
  597. (defun vm-su-hour (m)
  598.   (or (vm-hour-of m)
  599.       (progn (vm-su-do-date m) (vm-hour-of m))))
  600.  
  601. (defun vm-su-zone (m)
  602.   (or (vm-zone-of m)
  603.       (progn (vm-su-do-date m) (vm-zone-of m))))
  604.  
  605. (defun vm-su-mark (m) (if (vm-mark-of m) "*" " "))
  606.  
  607. ;; Some yogurt-headed delivery agents don't provide a Date: header.
  608. (defun vm-grok-From_-date (message)
  609.   ;; This works only on the From_ types, obviously
  610.   (if (not (memq (vm-message-type-of message)
  611.          '(From_ From_-with-Content-Length)))
  612.       nil
  613.     (save-excursion
  614.       (set-buffer (vm-buffer-of (vm-real-message-of message)))
  615.       (save-restriction
  616.     (widen)
  617.     (goto-char (vm-start-of message))
  618.     (let ((case-fold-search nil))
  619.       (if (or (looking-at
  620.            ;; special case this so that the "remote from blah"
  621.            ;; isn't included.
  622.            "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*")
  623.           (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)"))
  624.           (vm-buffer-substring-no-properties
  625.            (match-beginning 1)
  626.            (match-end 1))))))))
  627.  
  628. (defun vm-parse-date (date)
  629.   (let ((weekday "")
  630.     (monthday "")
  631.     (month "")
  632.     (year "")
  633.     (hour "")
  634.     (timezone "")
  635.     (start nil)
  636.     string
  637.     (case-fold-search t))
  638.     (if (string-match "sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat" date)
  639.     (setq weekday (substring date (match-beginning 0) (match-end 0))))
  640.     (if (string-match "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|jul\\|aug\\|sep\\|oct\\|nov\\|dec" date)
  641.     (setq month (substring date (match-beginning 0) (match-end 0))))
  642.     (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(:[0-9][0-9]\\)?" date)
  643.     (setq hour (substring date (match-beginning 0) (match-end 0))))
  644.     (if (or (string-match "[^a-z][+---][0-9][0-9][0-9][0-9]" date)
  645.         (string-match "e[ds]t\\|c[ds]t\\|p[ds]t\\|m[ds]t" date)
  646.         (string-match "ast\\|nst\\|met\\|eet\\|jst\\|bst\\|ut" date)
  647.         (string-match "gmt\\([+---][0-9]+\\)?" date))
  648.     (setq timezone (substring date (match-beginning 0) (match-end 0))))
  649.     (while (string-match "\\(\\`\\|[^:+---0-9]\\|[a-z]-\\)[0-9]+\\(\\'\\|[^:]\\)"
  650.              date start)
  651.       (setq string (substring date (match-end 1) (match-beginning 2))
  652.         start (match-end 0))
  653.       (cond ((string-match "\\`[4-9]." string)
  654.          ;; Assume that any two digits less than 40 are a date and not
  655.          ;; a year.  The world will surely end soon.
  656.          (setq year (concat "19" string)))
  657.         ((< (length string) 3)
  658.          (setq monthday string))
  659.         (t (setq year string))))
  660.     
  661.     (aset vm-parse-date-workspace 0 weekday)
  662.     (aset vm-parse-date-workspace 1 monthday)
  663.     (aset vm-parse-date-workspace 2 month)
  664.     (aset vm-parse-date-workspace 3 year)
  665.     (aset vm-parse-date-workspace 4 hour)
  666.     (aset vm-parse-date-workspace 5 timezone)
  667.     vm-parse-date-workspace))
  668.  
  669. (defun vm-su-do-date (m)
  670.   (let ((case-fold-search t)
  671.     vector date)
  672.     (setq date (or (vm-get-header-contents m "Date:") (vm-grok-From_-date m)))
  673.     (cond
  674.      ((null date)
  675.       (vm-set-weekday-of m "")
  676.       (vm-set-monthday-of m "")
  677.       (vm-set-month-of m "")
  678.       (vm-set-month-number-of m "")
  679.       (vm-set-year-of m "")
  680.       (vm-set-hour-of m "")
  681.       (vm-set-zone-of m ""))
  682.      ((string-match
  683. ;; The date format recognized here is the one specified in RFC 822.
  684. ;; Some slop is allowed e.g. dashes between the monthday, month and year
  685. ;; because such malformed headers have been observed.
  686. "\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)"
  687.        date)
  688.       (if (match-beginning 2)
  689.       (vm-set-weekday-of m (substring date (match-beginning 2)
  690.                       (match-end 2)))
  691.     (vm-set-weekday-of m ""))
  692.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  693.       (vm-su-do-month m (substring date (match-beginning 4) (match-end 4)))
  694.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  695.       (if (= 2 (length (vm-year-of m)))
  696.       (vm-set-year-of m (concat "19" (vm-year-of m))))
  697.       (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
  698.       (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7))))
  699.      ((string-match
  700. ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for
  701. ;; the possibility of a timezone at the end.
  702. "\\([a-z][a-z][a-z]\\)[ \t\n]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?"
  703.        date)
  704.       (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
  705.       (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
  706.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  707.       (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
  708.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  709.       (if (match-beginning 6)
  710.       (vm-set-zone-of m (substring date (match-beginning 6)
  711.                        (match-end 6)))))
  712.      (t
  713.       (setq vector (vm-parse-date date))
  714.       (vm-set-weekday-of m (elt vector 0))
  715.       (vm-set-monthday-of m (elt vector 1))
  716.       (vm-su-do-month m (elt vector 2))
  717.       (vm-set-year-of m (elt vector 3))
  718.       (vm-set-hour-of m (elt vector 4))
  719.       (vm-set-zone-of m (elt vector 5)))))
  720.  
  721.   ;; Normalize all hour and date specifications to avoid jagged margins.
  722.   ;; If the hour is " 3:..." or "3:...", turn it into "03:...".
  723.   ;; If the date is "03", turn it into " 3".
  724.   (cond ((null (vm-hour-of m)) nil)
  725.     ((string-match "\\`[0-9]:" (vm-hour-of m))
  726.      (vm-set-hour-of m (concat "0" (vm-hour-of m)))))
  727.   (cond ((null (vm-monthday-of m)) nil)
  728.     ((string-match "\\`0[0-9]\\'" (vm-monthday-of m))
  729.      (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2))))
  730.   )
  731.  
  732. (defun vm-su-do-month (m month-abbrev)
  733.   (let ((val (assoc (downcase month-abbrev) vm-month-alist)))
  734.     (if val
  735.     (progn (vm-set-month-of m (nth 1 val))
  736.            (vm-set-month-number-of m (nth 2 val)))
  737.       (vm-set-month-of m "")
  738.       (vm-set-month-number-of m ""))))
  739.  
  740. (defun vm-run-user-summary-function (function message)
  741.   (let ((message (vm-real-message-of message)))
  742.     (save-excursion
  743.       (set-buffer (vm-buffer-of message))
  744.       (save-restriction
  745.     (widen)
  746.     (save-excursion
  747.       (narrow-to-region (vm-headers-of message) (vm-text-end-of message))
  748.       (funcall function message))))))
  749.  
  750. (defun vm-su-full-name (m)
  751.   (or (vm-full-name-of m)
  752.       (progn (vm-su-do-author m) (vm-full-name-of m))))
  753.  
  754. (defun vm-su-interesting-full-name (m)
  755.   (if vm-summary-uninteresting-senders
  756.       (let ((case-fold-search nil))
  757.     (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
  758.         (concat vm-summary-uninteresting-senders-arrow (vm-su-to-names m))
  759.       (vm-su-full-name m)))
  760.     (vm-su-full-name m)))
  761.  
  762. (defun vm-su-from (m)
  763.   (or (vm-from-of m)
  764.       (progn (vm-su-do-author m) (vm-from-of m))))
  765.  
  766. (defun vm-su-interesting-from (m)
  767.   (if vm-summary-uninteresting-senders
  768.       (let ((case-fold-search nil))
  769.     (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
  770.         (concat vm-summary-uninteresting-senders-arrow (vm-su-to m))
  771.       (vm-su-from m)))
  772.     (vm-su-from m)))
  773.  
  774. ;; Some yogurt-headed delivery agents don't even provide a From: header.
  775. (defun vm-grok-From_-author (message)
  776.   ;; This works only on the From_ types, obviously
  777.   (if (not (memq (vm-message-type-of message)
  778.          '(From_ From_-with-Content-Length)))
  779.       nil
  780.     (save-excursion
  781.       (set-buffer (vm-buffer-of message))
  782.       (save-restriction
  783.     (widen)
  784.     (goto-char (vm-start-of message))
  785.     (let ((case-fold-search nil))
  786.       (if (looking-at "From \\([^ \t\n]+\\)")
  787.           (vm-buffer-substring-no-properties
  788.            (match-beginning 1)
  789.            (match-end 1))))))))
  790.  
  791. (defun vm-su-do-author (m)
  792.   (let ((full-name (vm-get-header-contents m "Full-Name:"))
  793.     (from (or (vm-get-header-contents m "From:")
  794.           (vm-grok-From_-author m)))
  795.     pair)
  796.     (if (and full-name (string-match "^[ \t]*$" full-name))
  797.     (setq full-name nil))
  798.     (if (null from)
  799.     (progn
  800.       (setq from "???")
  801.       (if (null full-name)
  802.           (setq full-name "???")))
  803.       (setq pair (funcall vm-chop-full-name-function from)
  804.         from (or (nth 1 pair) from)
  805.         full-name (or full-name (nth 0 pair) from)))
  806.     (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
  807.      (setq full-name
  808.            (substring full-name (match-beginning 1) (match-end 1))))
  809.     (vm-set-full-name-of m full-name)
  810.     (vm-set-from-of m from)))
  811.  
  812. (defun vm-default-chop-full-name (address)
  813.   (let ((from address)
  814.     (full-name nil))
  815.     (cond ((string-match
  816. "\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*<\\([^>]+\\)>[ \t\n]*\\'"
  817.              address)
  818.        (if (match-beginning 1)
  819.            (setq full-name
  820.              (substring address (match-beginning 1) (match-end 1))))
  821.        (setq from
  822.          (substring address (match-beginning 3) (match-end 3))))
  823.       ((string-match
  824. "\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'"
  825.              address)
  826.        (if (match-beginning 3)
  827.            (setq full-name
  828.              (substring address (match-beginning 3) (match-end 3))))
  829.        (setq from
  830.          (substring address (match-beginning 1) (match-end 1)))))
  831.     (list full-name from)))
  832.  
  833. ;; test for existence and functionality of mail-extract-address-components
  834. ;; there are versions out there that don't work right, so we run
  835. ;; some test data through it to see if we can trust it.
  836. (defun vm-choose-chop-full-name-function (address)
  837.   (let ((test-data '(("kyle@uunet.uu.net" .
  838.               (nil "kyle@uunet.uu.net"))
  839.              ("c++std=lib@inet.research.att.com" .
  840.               (nil "c++std=lib@inet.research.att.com"))
  841.              ("\"Piet.Rypens\" <rypens@reks.uia.ac.be>" .
  842.               ("Piet Rypens" "rypens@reks.uia.ac.be"))
  843.              ("makke@wins.uia.ac.be (Marc.Gemis)" .
  844.               ("Marc Gemis" "makke@wins.uia.ac.be"))
  845.              ("" . (nil nil))))
  846.     (failed nil)
  847.     result)
  848.     (while test-data
  849.       (setq result (condition-case nil
  850.                (mail-extract-address-components (car (car test-data)))
  851.              (error nil)))
  852.       (if (not (equal result (cdr (car test-data))))
  853.       ;; failed test, use default
  854.       (setq failed t
  855.         test-data nil)
  856.     (setq test-data (cdr test-data))))
  857.     (if failed
  858.     ;; it failed, use default
  859.     (setq vm-chop-full-name-function 'vm-default-chop-full-name)
  860.       ;; it passed the tests
  861.       (setq vm-chop-full-name-function 'mail-extract-address-components))
  862.     (funcall vm-chop-full-name-function address)))
  863.  
  864. (defun vm-su-do-recipients (m)
  865.   (let ((mail-use-rfc822 t) names addresses to cc all list)
  866.     (setq to (or (vm-get-header-contents m "To:")
  867.          (vm-get-header-contents m "Apparently-To:")
  868.          ;; desperation....
  869.          (user-login-name))
  870.       cc (vm-get-header-contents m "Cc:")
  871.       all to
  872.       all (if all (concat all ", " cc) cc)
  873.       addresses (rfc822-addresses all))
  874.     (setq list (vm-parse-addresses all))
  875.     (while list
  876.       (cond ((string= (car list) ""))
  877.         ((string-match "^\\(\"?\\([^<]+[^ \t\n\"]\\)\"?[ \t\n]+\\)?<\\([^>]+\\)>"
  878.                (car list))
  879.          (if (match-beginning 2)
  880.          (setq names
  881.                (cons
  882.             (substring (car list) (match-beginning 2)
  883.                    (match-end 2))
  884.             names))
  885.            (setq names
  886.              (cons
  887.               (substring (car list) (match-beginning 3)
  888.                  (match-end 3))
  889.               names))))
  890.         ((string-match "[\000-\177]*(\\([^)]+\\))[\000-\177]*" (car list))
  891.          (setq names
  892.            (cons (substring (car list) (match-beginning 1)
  893.                     (match-end 1))
  894.              names)))
  895.         (t (setq names (cons (car list) names))))
  896.       (setq list (cdr list)))
  897.     (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses
  898.     (vm-set-to-of m (mapconcat 'identity addresses ", "))
  899.     (vm-set-to-names-of m (mapconcat 'identity names ", "))))
  900.  
  901. (defun vm-su-to (m)
  902.   (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m))))
  903.  
  904. (defun vm-su-to-names (m)
  905.   (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m))))
  906.                   
  907. (defun vm-su-message-id (m)
  908.   (or (vm-message-id-of m)
  909.       (vm-set-message-id-of
  910.        m
  911.        (or (vm-get-header-contents m "Message-Id:")
  912.        ;; try running md5 on the message body to produce an ID
  913.        ;; better than nothing.
  914.        (save-excursion
  915.          (set-buffer (vm-buffer-of (vm-real-message-of m)))
  916.          (save-restriction
  917.            (widen)
  918.            (condition-case nil
  919.            (concat "<fake-VM-id."
  920.                (vm-pop-md5-string
  921.                 (buffer-substring
  922.                  (vm-text-of (vm-real-message-of m))
  923.                  (vm-text-end-of (vm-real-message-of m))))
  924.                "@talos.iv>")
  925.          (error nil))))
  926.        (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>")))))
  927.  
  928. (defun vm-su-line-count (m)
  929.   (or (vm-line-count-of m)
  930.       (vm-set-line-count-of
  931.        m
  932.        (save-excursion
  933.      (set-buffer (vm-buffer-of (vm-real-message-of m)))
  934.      (save-restriction
  935.        (widen)
  936.        (int-to-string
  937.         (count-lines (vm-text-of (vm-real-message-of m))
  938.              (vm-text-end-of (vm-real-message-of m)))))))))
  939.  
  940. (defun vm-su-subject (m)
  941.   (or (vm-subject-of m)
  942.       (vm-set-subject-of
  943.        m
  944.        (let ((subject (or (vm-get-header-contents m "Subject:") ""))
  945.          (i nil))
  946.      (if vm-summary-subject-no-newlines
  947.          (while (setq i (string-match "\n" subject i))
  948.            (aset subject i ?\ )))
  949.      subject ))))
  950.  
  951. (defun vm-su-summary (m)
  952.   (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m)))
  953.       (or (vm-virtual-summary-of m)
  954.       (save-excursion
  955.         (vm-select-folder-buffer)
  956.         (vm-set-virtual-summary-of m (vm-sprintf 'vm-summary-format m t))
  957.         (vm-virtual-summary-of m)))
  958.     (or (vm-summary-of m)
  959.     (save-excursion
  960.       (vm-select-folder-buffer)
  961.       (vm-set-summary-of m (vm-sprintf 'vm-summary-format m t))
  962.       (vm-summary-of m)))))
  963.  
  964. (defun vm-fix-my-summary!!! ()
  965.   (interactive)
  966.   (vm-select-folder-buffer)
  967.   (vm-check-for-killed-summary)
  968.   (vm-error-if-folder-empty)
  969.   (vm-unsaved-message "Fixing your summary...")
  970.   (let ((mp vm-message-list))
  971.     (while mp
  972.       (vm-set-summary-of (car mp) nil)
  973.       (vm-mark-for-summary-update (car mp))
  974.       (vm-stuff-attributes (car mp))
  975.       (setq mp (cdr mp)))
  976.     (set-buffer-modified-p t)
  977.     (vm-update-summary-and-mode-line))
  978.   (vm-unsaved-message "Fixing your summary... done"))
  979.  
  980. (defun vm-su-thread-indent (m)
  981.   (if (natnump vm-summary-thread-indent-level)
  982.       (make-string (* (vm-th-thread-indentation m)
  983.               vm-summary-thread-indent-level)
  984.            ?\ )
  985.     "" ))
  986.  
  987. (defun vm-su-labels (m)
  988.   (or (vm-label-string-of m)
  989.       (vm-set-label-string-of
  990.        m
  991.        (mapconcat 'identity (vm-labels-of m) ","))
  992.       (vm-label-string-of m)))
  993.